home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 8: LINUX Games / Linux Cubed Series 8 - LINUX Games.iso / games / role / roleplay.0-s / roleplay / RolePlaying-1.0 / scripts / searchbox.tcl < prev    next >
Text File  |  1995-07-09  |  11KB  |  367 lines
  1. # orig: /home/yew/yew5/users/phelps/spine/RCS/searchbox.tcl,v 1.2 1993/08/19 00:11:30 phelps Exp phelps $
  2. # RCS: $Header: /home/heller/Deepwoods/RolePlaying/RCS/searchbox.tcl,v 1.1 1995/07/09 22:09:28 heller Exp $
  3.  
  4. #
  5. # SearchBox mega widget
  6. #   incremental and regular expression searching in a text widget
  7. #
  8. #   by Tom Phelps (phelps@cs.Berkeley.EDU)
  9. #
  10. # extracted from and then used by TkMan and NBT 6-Aug-93
  11. #
  12. # 19-Aug  made more robust (Kennard White)
  13. #
  14.  
  15. # requires: proc regexpTextSearch
  16. # name space use: prefixes searchbox, sb, sbx
  17.  
  18.  
  19.  
  20. ### default key bindings
  21. # ""=unmodified, S=shift, A=alt, C=control, M=meta
  22.  
  23. set sb(key,*) "add modifiers in this order: M, C, A, S"
  24. set sb(key,C-x) exchangepointandmark
  25. set sb(key,C-space) setmark
  26. set sb(key,-Delete) pageup
  27. set sb(key,M-v) pageup
  28. set sb(key,-space) pagedown
  29. set sb(key,C-v) pagedown
  30. set sb(key,MS-less) pagestart
  31. set sb(key,MS-greater) pageend
  32. set sb(key,-Escape) searchkill
  33. set sb(key,C-g) searchkill
  34. set sb(key,C-n) nextline
  35. set sb(key,C-p) prevline
  36. set sb(key,C-s) incrsearch
  37. set sb(key,C-r) revincrsearch
  38. set sb(key,MS-question) help
  39. set sb(key,-Help) help
  40.  
  41.  
  42.  
  43. #--------------------------------------------------
  44. #
  45. # searchboxRegexpSearch -- initiate a regular expression search
  46. #
  47. # params
  48. #    str = string to search for
  49. #    regexp = boolean - regular expression search?
  50. #    casesen = case sensitive?
  51. #    tag = tag to associate with matches
  52. #       (do a `tag bind' in the text widget for this tag)
  53. #    w = text widget
  54. #    wv = associated vertical scrollbar
  55. #    wmsg = (optional) window to show status messages
  56. #    wcnt = (optional) widget to show number of matches
  57. #
  58. #
  59. #--------------------------------------------------
  60.  
  61. proc searchboxSearch {str regexp casesen tag w wv {wmsg ""} {wcnt ""}} {
  62.    global sbx
  63. #puts stdout "searchboxRegexpSearch $str $casesen w=$w $wv wmsg=$wmsg $wcnt"
  64.    if {$str==""} {
  65.       winerrout $wmsg "Nothing to search for!  Type a regexp and click `Search'."
  66.       return
  67.    }
  68.  
  69.    if {$regexp} {set type regexp} {set type ""}
  70.    set cnt [${type}TextSearch $w $str $tag $casesen]
  71.    if {$cnt==-1} {winerrout $wmsg "Malformed regular expression."; return}
  72.    if {$cnt==1} {set txt "$cnt match"} {set txt "$cnt matches"}
  73.    winstdout $wcnt $txt
  74.  
  75.    # show the first one
  76. #   set sbx(search) 1.0
  77. #   $w yview 0; update idletasks
  78.    # show the next match
  79.    searchboxNext $tag $w $wv $wmsg [expr [lindex [$wv get] 2]+1].0
  80. }
  81.  
  82.  
  83.  
  84. #--------------------------------------------------
  85. #
  86. # searchboxNext -- show the next match
  87. #
  88. # params
  89. #    tag = tag to search for (see searchboxRegexpSearch)
  90. #    w = text widget
  91. #    wv = associated vertical scrollbar
  92. #    wmsg = window to show status messages
  93. #
  94. #--------------------------------------------------
  95.  
  96. proc searchboxNext {tag w wv {wmsg ""} {next ""}} {
  97.    global sbx
  98.  
  99. #   set tmp [$w tag nextrange search [max [expr [lindex [$wv get] 2]+1].0 $sbx(search)]]
  100.    if {$next==""} {set next [expr [lindex [$wv get] 3]+1+1].0}
  101.    set tmp [$w tag nextrange $tag $next]
  102.    if {$tmp==""} {
  103.       winstdout $wmsg "No more matches; restarting at top."
  104.       $w yview 0
  105. #      set sbx(search) 1.0
  106.    } else {
  107.       $w yview -pickplace [lindex $tmp 0]
  108.       update
  109. #      winstdout $wmsg "Viewing lines [lindex [$wv get] 2] to [lindex [$wv get] 3]."
  110. #      set sbx(search) [expr [lindex [$wv get] 3]+1+1].0
  111.    }
  112. }
  113.  
  114.  
  115.  
  116. #--------------------------------------------------
  117. #
  118. # searchboxKeyNav -- keyboard-based navigation and searching
  119. #
  120. #   maybe separate out some commands so incrsearch doesn't have to wade through
  121. #
  122. # params:
  123. #   m = modifier key
  124. #   k = key
  125. #   casesen = case sensitive?
  126. #   w = text widget
  127. #   wv = associated vertical scrollbar
  128. #   wmsg = label in which to show incremental search string
  129. #   mode = 1=>match on first character of line, 0=>match anywhere
  130. #
  131. #--------------------------------------------------
  132.  
  133. proc searchboxKeyNav {m k casesen w wv {wmsg ""} {firstmode 0}} {
  134.    global sb sbx
  135.  
  136.    if {[regexp {(Shift|Control|Meta)_.} $k]} return
  137.    if {![info exists sbx(try$w)]} {
  138.       set sbx(try$w) 0
  139.       set sbx(vect$w) 1
  140.       set sbx(lastkeys$w) [set sbx(lastkeys-old$w) ""]
  141.    }
  142.  
  143.  
  144.    # get initial values
  145.    set minele 1
  146.    if {[winfo class $w]=="Text"} {set off 1; scan [$w index end] %d numLines} \
  147.    elseif {[winfo class $w]=="Listbox"} {set off 0; set numLines [$w size]; set minele 0}
  148.    scan [$wv get] "%d %d %d %d" total window first last
  149.  
  150.  
  151.    # some translations
  152.    if {$sbx(try$w) || $sbx(lastkeys$w)!=""} {
  153.       switch -exact -- $k {
  154.          space {set k " "}
  155.          Delete {
  156.             set k ""
  157.             set last [expr [string length $sbx(lastkeys$w)]-2]
  158.             set sbx(lastkeys$w) [string range $sbx(lastkeys$w) 0 $last]
  159.             set sbx(try$w) 1
  160.          }
  161.          default { if {$m==""||$m=="S"} {set k [name2char $k]} }
  162.       }
  163.    }
  164.  
  165.  
  166.    # commands
  167.    set mk $m-$k
  168.    if {[info exists sb(key,$mk)]} {set op $sb(key,$mk)} {set op default}
  169. #puts stdout "trying for a match on $mk"
  170. #puts stdout "*$sb(setmark)* *$sb(pageup)* *$sb(pagedown)*"
  171.    switch -exact -- $op {
  172.       help {$w.occ.m invoke Help; return}
  173.       exchangepointandmark {
  174.          # yview w/o parameter should return current value
  175.          set tmp [expr [lindex [$wv get] 2]+1].0
  176.          $w yview xmark
  177.          update
  178.          $w mark set xmark $tmp
  179.       }
  180.       setmark {$w mark set xmark [expr [lindex [$wv get] 2]+1].0}
  181.       pageup {$w yview [max [expr $first-$window+1] 0]}
  182.       pagedown {$w yview [min [expr $first+$window-1] [expr $numLines-$window]]}
  183.       pagestart {$w yview 0}
  184.       pageend {$w yview [max [expr $numLines-$window] 0]}
  185.       searchkill {
  186.          if {$sbx(lastkeys$w)!=""} {set sbx(lastkeys-old$w) $sbx(lastkeys$w)}
  187.          set sbx(lastkeys$w) ""; set sbx(try$w) 0; winstdout $wmsg ""
  188.       }
  189.       C-l {$w yview [max [expr $first-$window/2] 0]}
  190.       nextline {$w yview [min [expr $first+1] [expr $numLines-$window]]}
  191.       prevline {$w yview [max [expr $first-1] 0]}
  192.       default {
  193.          # incremental search
  194.          if {$op=="incrsearch"} {
  195.             # C-s C-s retrieves last search pattern
  196.             if {$sbx(try$w)&&$sbx(lastkeys$w)==""} {set sbx(lastkeys$w) $sbx(lastkeys-old$w)}
  197.             incr off; set sbx(vect$w) 1; set sbx(try$w) 1
  198.          } elseif {$op=="revincrsearch"} {
  199.             if {$sbx(try$w)&&$sbx(lastkeys$w)==""} {set sbx(lastkeys$w) $sbx(lastkeys-old$w)}
  200.             incr off -1; set sbx(vect$w) -1; set sbx(try$w) 1
  201.          } elseif {$firstmode} {
  202.             set sbx(lastkeys$w) $k
  203.          } elseif {$sbx(try$w)} {
  204.         append sbx(lastkeys$w) $k
  205.          } else return
  206.  
  207.          if {$firstmode} {
  208.             set curline 0
  209.          } else {
  210.             set curline [lindex [$wv get] 2]
  211.             winstdout $wmsg "Searching for \"$sbx(lastkeys$w)\" ..."; update idletasks
  212.          }
  213.          if {[set keys $sbx(lastkeys$w)]==""} return
  214.  
  215.          set klen [string length $keys]
  216.          set found -1
  217.          for {set i [expr $curline+$off]} {$minele<=$i && $i<=$numLines} {incr i $sbx(vect$w)} {
  218.             if {$firstmode} {
  219.                if {"$keys"=="[$w get $i.0 $i.$klen]"} {set found 0; break}
  220.             } elseif {!$casesen} {
  221.                if {[set found [string first [string tolower $keys] \
  222.                   [string tolower [$w get $i.0 "$i.0 lineend"]]]]!=-1} \
  223.                   break;
  224.             } elseif {[set found [string first $keys [$w get $i.0 "$i.0 lineend"]]]!=-1} {
  225.                break
  226.             }
  227.          }
  228.  
  229.          # show results
  230.          if {$found!=-1} {
  231.             $w yview [expr $i-1]; update idletasks
  232.             if {!$firstmode} {winstdout $wmsg "\"$keys\" found on line $i"}
  233.          } elseif {$op=="incrsearch"} {
  234.             $w yview 0
  235.             winstdout $wmsg "No more matches found; restarting search at top."
  236.          } elseif {$op=="revincrsearch"} {
  237.              $w yview $total
  238.         winstdout $wmsg "No more match found; restarting search at bottom."
  239.          } else {
  240.             winstdout $wmsg "\"$keys\" not found"
  241.             # turn off searching once can't match what you have
  242.             set sbx(try$w) 0
  243.          }
  244.       }
  245.    }
  246. }
  247.  
  248.  
  249.  
  250. #--------------------------------------------------
  251. #
  252. # searchboxSaveConfig -- dump persistent variables into passed file id
  253. #
  254. #--------------------------------------------------
  255.  
  256. proc searchboxSaveConfig {fid} {
  257.    global sb sbx
  258.  
  259.    puts $fid "#\n# SearchBox\n#\n"
  260.    foreach i [lsort [array names sb]] {
  261.       puts $fid "set sb($i) [list $sb($i)]"
  262.    }
  263.    puts $fid "\n"
  264. }
  265.  
  266.  
  267.  
  268. # swiped from mkTextSearch w
  269. #
  270. # The utility procedure below searches for all instances of a
  271. # given string in a text widget and applies a given tag to each
  272. # instance found.
  273. # Arguments:
  274. #
  275. # w -        The window in which to search.  Must be a text widget.
  276. # string -    The string to search for.  The search is done using
  277. #        exact matching only;  no special characters.
  278. # tag -        Tag to apply to each instance of a matching string.
  279. # case -        (optional) case sensitive?
  280.  
  281. proc TextSearch {w string tag {case 1}} {
  282.    set cnt 0
  283.  
  284.     $w tag remove $tag 0.0 end
  285.     scan [$w index end] %d numLines
  286.     set l [string length $string]
  287.     if {!$case} {set string [string tolower $string]}
  288.     for {set i 1} {$i <= $numLines} {incr i} {
  289.     set match [$w get $i.0 $i.1000]
  290.     if {!$case} {set match [string tolower $match]}
  291.     if {[string first $string $match] == -1} {
  292.         continue
  293.     }
  294.     set line [$w get $i.0 $i.1000]
  295.     set offset 0
  296.     while 1 {
  297.         set index [string first $string $line]
  298.         if {$index < 0} {
  299.         break
  300.         }
  301.         incr offset $index
  302.         $w tag add $tag $i.[expr $offset] $i.[expr $offset+$l]
  303.             incr cnt
  304.         incr offset $l
  305.         # below bug fix from mkSearch.tcl
  306.         set line [string range $line [expr $index+$l] 1000]
  307.     }
  308.     }
  309.    return $cnt
  310. }
  311.  
  312.  
  313. # modified to handle regexp's and return # of matches -TAP
  314.  
  315. proc regexpTextSearch {w string tag {case 1}} {
  316.    set cnt 0
  317.    if {$case} {set case ""} {set case "-nocase"}
  318.    if {[catch {regexp $string bozomaniac}]} {return -1}
  319.  
  320.     $w tag remove $tag 0.0 end
  321.     scan [$w index end] %d numLines
  322.  
  323.     for {set i 1} {$i <= $numLines} {incr i} {
  324.       set line [$w get $i.0 $i.1000]
  325.       set offset 0
  326.       while 1 {
  327.          if {![eval regexp $case -indices {"$string"} {"$line"} match]} break
  328.          scan $match "%d %d" index iend
  329.          $w tag add $tag $i.[expr $offset+$index] $i.[expr $offset+$iend+1]
  330.          set line [string range $line [expr $iend+1] end]
  331.          incr offset [expr $iend+1]
  332.          incr cnt
  333.       }
  334.    }
  335.    return $cnt
  336. }
  337.  
  338.  
  339.  
  340. # instantiate standard mechanisms if don't already exist
  341. if {[info procs winstdout]==""} {
  342.  
  343. proc winerrout {w msg} {
  344.    if {![winfo exists $w]} return
  345.  
  346.    set fg [lindex [$w configure -foreground] 4]
  347.    set bg [lindex [$w configure -background] 4]
  348.  
  349.    winstdout $w $msg
  350.    $w configure -foreground $bg -background $fg
  351.    update idletasks; after 500
  352.    $w configure -foreground $fg -background $bg
  353. }
  354.  
  355. proc winstdout {w msg} {
  356.    global winout
  357.  
  358.    if {![winfo exists $w]} return
  359.    $w configure -text $msg
  360.    set winout(lastMessage$w) $msg
  361. }
  362.  
  363. }
  364.  
  365.  
  366.  
  367.